home *** CD-ROM | disk | FTP | other *** search
* Program CSETRANS - Tracks transportation assignments Select secondary Store 'TRAN=' to infield If len(MSEL) > 2 Store msel+' ' to msel Store $(msel,2,5) to inlodg Store infield+inlodg to sfield Find &sfield If #=0 Accept 'Transportation code not found. Press <return> ' to xx RETURN endif else ? ' ',ename,' TRANSPORTATION names '+curdate Find &INFIELD If #=0 Accept 'No Transportation codes found. Enter them from Set Up. Press <retn>' ; to xx RETURN endif Store ' ' to romvalid Set raw on Do while spact=infield.and. .not. EOF Store romvalid+$(spact,5,6) to romvalid Store $(spact,1,11) to innf ? '[',$(spact,6,5),'] ',$(spact,11,28) Do while (spact=innf.or.$(spact,11,1)='.').and. .not.EOF SKIP enddo enddo Store 'Y' to xsel ? ? 'VALID TRANSPORTATION CODES: ',romvalid Set raw off ? Accept ' Select a TRANSPORTATION code (5 characters) ' to inlodg Store F to goodlodg Do while .not. goodlodg STORE INLODG+' ' to inlodg Store $(inlodg,1,5) to inlodg Store '='+inlodg to innlodge Store T to goodlodg If !(inlodg)='Q ' Store T to goodlodg else If @(innlodge,romvalid)=0 Accept 'Transportation code is not found. Enter another ' to inlodg Store F to goodlodg else Store 'TRAN'+innlodge to sfield Find &sfield If #=0 Accept 'Transportation code is not found. Enter another' to inlodg Store 'n' to xsel Store F to goodlodg endif endif endif enddo endif If inlodg<>'Q ' Store '['+$(spact,6,5)+'] '+trim($(spact,11,28)) to romname Store $(spact,1,11) to sfield Release inlodg,romvalid,goodlodg,innlodge,innf Store ' ' to xsel Store str(#,5) to xrec Do while !(xsel)<>'Q' Select secondary GOTO &xrec SKIP Erase @ 1,0 say ROMNAME+' '+ename @ 1,64 say curdate Store 3 to I Store 3 to J Store ' ' to inumbs Store 0 to II Do while spact=sfield .and. .not. EOF Store 3 to I Store 3 to J Do while J<80 .and. spact=sfield .and. .not. EOF Store II+1 to II @ I,J say str(II,2) @ I,J+3 say $(spact,11,28) Store inumbs+str(#,5) to inumbs SKIP store I+1 to I If I=23 Store J+40 to J Store 3 to I endif enddo enddo Store ' ' to xsel Do while !(xsel)<>'Q'.and.!(xsel)<>'S' @ 22,78 say ' ' Accept ; 'Select: A]dd C]hange D]elete R]eport S]creen V]erify Q]uit ' ; to xsel Do CASE CASE !(xsel)='V' Select secondary GOTO &xrec Store F to nonams SKIP If spact<>sfield Store T to nonams endif If nonams Accept "No names are assigned to Transportation code. Press <retn>" to xx else ? 'Now verifying EDIRFILE names against Transportation assignments in MEMBERSE' ? ; 'This routine clears any names in the EDIRFILE that do not match in MEMBERSE.' Accept 'OK? ' to xx If !(xx)='Y' Do while spact=sfield Store $(spact,6,6) to sfind Store $(spact,12,11) to nfind Store trim($(spact,24,10)) to ffind Select primary Store F to nfound If NFIND<>' ' Find &NFIND If #<>0 Do while last:name=nfind .and. first:name<>ffind.and. .not. EOF SKIP enddo If last:name=nfind.and. first:name=ffind Store T to nfound endif endif If nfound If transpor=sfind ? transpor,' ',nfind,ffind,' > > > VERIFIED < < <' else ? transpor,' ',nfind,ffind,' Transportation does not match in MEMBERSE ' Select secondary SKIP -1 Store str(#,5) to orec SKIP Replace spact with $(spact,1,10)+'.' GOTO &orec endif else ? transpor,' ',nfind,ffind,' Name is not found in MEMBERSE.' Select secondary SKIP -1 Store str(#,5) to orec SKIP Replace spact with $(spact,1,10)+'.' GOTO &OREC endif endif Select secondary SKIP enddo endif endif CASE !(xsel)='A' If II>39 Accept 'Maximum Transportation assignments have been reached. Press <retn> to x else Select secondary Store xsel+' ' to xsel ? 'Enter a new name for this Transportation code' Select primary Do CSECHECK.CMD If FOUND Store F to CHOLD Store $(last:name,1,11)+' '+$(first:name,1,10) to names If transpor = ' ' Store T to CHOLD Replace transpor with $(sfield,6,5) else Store transpor to xx Store 'TRAN='+transpor to nnfind Store $(last:name,1,11)+' '+$(first:name,1,10) to names Select secondary Find &nnfind If #=0 .or. names<>$(spact,12,22) Store T to CHOLD ? nnfind,' is not valid for - ',names,'Now being replaced.' Select primary Replace transpor with ' ' else ? 'This name already has a Transportation. You must select another.' endif endif else *FOUND ? 'No Transportation Name added.' store F to chold endif * FOUND If CHOLD Select secondary Append blank Store II+1 to II ? 'New Transportation assignment: ',$(sfield,6,5),' -->',names Replace spact with sfield+names endif endif * valid "intrans" CASE !(XSEL)='C' .or. !(XSEL)='D' Do CSETCHNG.CMD CASE !(xsel)='R' Release inbed,nnfind,ffind,oldrec,chold GOTO &xrec SKIP Set format to print Store ROMNAME+' '+ename to xx If len(xx)>59 Store $(xx,1,59) to xx endif @ 1,0 say xx @ 1,62 say curdate Store 1 to I Store 0 to II Store 3 to J Store ' ' to inumbs Store ' ' to xx Store str(#,5) to irec Store ' 0' to jrec Do while I<21.and.spact=sfield.and..not.EOF Store II+1 to II Store xx+str(II,2) to xx Store inumbs+str(#,5) to inumbs SKIP Store I+1 to I enddo If spact=sfield Store str(#,5) to Jrec endif GOTO &IREC Store 3 to I Do while (spact=sfield .and. I<23) .and. .not. EOF @ I,3 say $(xx,I*2,2)+$(spact,11,28) SKIP Store str(#,5) to irec If jrec<>' 0' Store II+1 to II GOTO &jrec Store inumbs+str(#,5) to inumbs @ I,40 say str(I+18,2)+$(spact,11,28) Store SKIP Store str(#,5) to jrec If spact<>sfield Store ' 0' to jrec endif endif Store I+1 to I GOTO &IREC enddo EJECT Set format to screen CASE !(xsel)='Q' .or.!(xsel)='S' .or. xsel=' ' otherwise ? 'Invalid entry. Please enter again ' endcase ? enddo enddo endif Release infield,romname,sfield,xrec,I,J,nobed,inbed,infind,found,names Release nfind,nnfind,ffind,nfound,oldrec,CHOLD,irec,jrec RETURN RETURN ,irec,jrec RETURN c RETURN HOLD,irec,jrec RETURN Append blank Store II+1 to II ? 'New Tr Andersen Gary Andersen Norm Anderson Carl Baker Diane Baker Jim Donaldson Eric Freed Terry Johnson Alice Johnson Linda Packer Sally Thompson Sally Thompson Sarah Williams Marlene Williams Martha Williams Rachel Williams 
